home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Camelot / Camelot 098 (1990-12)(Swedish User Group of Amiga)(SE)(PD)[WB].zip / Camelot 098 (1990-12)(Swedish User Group of Amiga)(SE)(PD)[WB].adf / XLisp-Stat / Functions / parallelplot.lsp < prev    next >
Lisp/Scheme  |  1990-10-11  |  4KB  |  94 lines
  1. ; book pp.329-334
  2.  
  3. (defproto parallel-plot-proto '(v) () graph-proto)
  4. (send parallel-plot-proto :title "Parallel Plot")
  5. (defmeth parallel-plot-proto :isnew (m &rest args)
  6.   (setf (slot-value 'v) 0)
  7.   (apply #'call-next-method (+ 1 m) args)
  8.   (send self :content-variables m 0))
  9. (defmeth parallel-plot-proto :current-axis
  10.          (&optional (i nil set) &key (draw t))
  11.   (when set
  12.         (setf (slot-value 'v) i)
  13.         (let* ((n (send self :num-points))
  14.                (m (- (send self :num-variables) 1))
  15.                (i (max 0 (min i (- m 1)))))
  16.         (if (< 0 n)
  17.             (send self :point-coordinate m (iseq n) i))
  18.         (send self :content-variables m i))
  19.       (if draw (send self :redraw)))
  20.   (slot-value 'v))
  21. (defmeth parallel-plot-proto :choose-current-axis ()
  22.   (let* ((choices
  23.            (mapcar #'(lambda (x) (format nil "~d" x))
  24.                    (iseq (- (send self :num-variables) 1))))
  25.          (v (choose-item-dialog "Current Axis:"
  26.              choices :initial (send self :current-axis))))
  27.    (if v (send self :current-axis v))))
  28. (defmeth parallel-plot-proto :menu-template ()
  29.   (flet ((action () (send self :choose-current-axis)))
  30.     (let ((item (send menu-item-proto :new "Current Variable"
  31.                       :action #'action)))
  32.       (append (call-next-method) (list item)))))
  33. (defmeth parallel-plot-proto :adjust-to-data (&key (draw t))
  34.   (call-next-method :draw nil)
  35.   (let ((m (- (send self :num-variables) 1)))
  36.     (if (null (send self :scale-type))
  37.        (flet ((expand-range (i)
  38.                 (let* ((range (send self :range i))
  39.                        (mid (mean range))
  40.                        (half (- (second range) (first range)))
  41.                        (low (- mid (* .55 half)))
  42.                        (high (+ mid (* .55 half))))
  43.                   (send self :range i low high :draw nil))))
  44.          (dotimes (i m) (expand-range i))))
  45.   (send self :scale m 1 :draw nil)
  46.   (send self :center m 0 :draw nil)
  47.   (send self :range m -.1 (- m .9) :draw draw)))
  48. (defmeth parallel-plot-proto :add-points (data &key (draw t))
  49.   (let ((n (length (first data))))
  50.     (call-next-method (append data (list (repeat 0 n))) :draw nil))
  51.   (send self :current-axis
  52.       (send self :current-axis) :draw draw))
  53. (defmeth parallel-plot-proto :add-lines (&rest args)
  54.   (error :"Lines are not meaningful for this plot"))
  55. (defmeth parallel-plot-proto :resize ()
  56.   (call-next-method)
  57.   (let ((height (fourth (send self :content-rect)))
  58.         (m (- (send self :num-variables) 1)))
  59.     (send self :canvas-range (iseq m) 0 height)))
  60. (defmeth parallel-plot-proto :draw-parallel-point (i)
  61.   (let* ((points (if (numberp i) (list i) i))
  62.          (width (third (send self :content-rect)))
  63.          (origin (send self :content-origin))
  64.          (x-origin (first origin))
  65.          (y-origin (second origin))
  66.          (m (- (send self :num-variables) 1))
  67.          (gap (/ width (+ (- m 1) .2)))
  68.          (xvals (+ x-origin (round (* gap (+ .1 (iseq 0 (- m 1)))))))
  69.          (indices (iseq 0 (- m 1)))
  70.          (oldcolor (send self :draw-color)))
  71.       (dolist (i points)
  72.         (if (send self :point-showing i)
  73.             (let* ((color (send self :point-color i))
  74.                    (yvals (- y-origin (send self
  75.                                         :point-canvas-coordinate indices i)))
  76.                    (poly (transpose (list xvals yvals))))
  77.                (if color (send self :draw-color color))
  78.                (send self :frame-poly poly)
  79.                (if color (send self :draw-color oldcolor)))))))
  80. (defmeth parallel-plot-proto :redraw-content ()
  81.   (let ((indices (iseq (send self :num-points))))
  82.      (send self :start-buffering)
  83.      (call-next-method)
  84.      (send self :draw-parallel-point indices)
  85.      (send self :buffer-to-screen)))
  86. (defun parallel-plot (data &rest args &key point-labels)
  87.   (let ((graph (apply #'send parallel-plot-proto :new
  88.                       (length data) :draw nil args)))
  89.      (if point-labels
  90.          (send graph :add-points data :point-labels point-labels :draw nil)
  91.          (send graph :add-points data :draw nil))
  92.          (send graph :adjust-to-data :draw nil)
  93.          graph))
  94.